BBS Toolkit/BBS Toolkit.iso/ezy_comm/ezy1023.zip/EKIT102.ZIP/EZYINC.PAS

Pascal/Delphi Source File | 1992-10-24 | 13KB | 552 lines

(* EZYINC V1.00 - An Ezycom General Purpose TP Unit

   Copyright Peter Davies 1992.  All Rights Reserved.

   This source may be freely used as long as due credit is given.
   That means, in your documentation, you MUST acknowledge that
      "EZYINC Copyright Peter Davies 1992" was used.

   EZYINC is a general purpose unit for Ezycom Utilities
   Simply add EZYINC to your uses statement

   Features: General Purpose Procedures
             Automatic Reading of CONFIG.EZY into configrec
             -N<node> and/or TASK aware
                (node number stored in "node")
             Inline Assembly on highly used routines *)

unit ezyinc;

{$F+,R-,S-,V-}
Interface

uses Crt, dos;

{$I struct}

procedure setbit(position, value : byte; var changebyte : byte);
procedure setbitbyte(position : byte;value : boolean;var changebyte : byte);
   (* Set a Bit at Position <0-7> to On=1 or Off=0 *)

procedure setbitword(position : byte;value : boolean; var changeword : word);
   (* Set a Bit at Position <0-15> to Value *)

function biton(position : byte;testword : word) : boolean;
   (* Test if Bit Position <0-15> is on in TestWord
      Note: Also works on Bytes *)

function itospad(x : longint;padout : byte) : str12;
   (* Returns a String from a Number, padded with leading 0s padout size *)

function itos(x : longint) : str12;
   (* Returns a String from a Number *)

function dig2(s : word) : str2;
   (* Return a 2 Digit String ranging 00 to 99 *)

function low2up(line : maxstr) : maxstr;
   (* Convert Lowercase to Uppercase *)

function find(path : maxstr) : boolean;
   (* Returns True if PATH exists *)

function findw(s : maxstr) : maxstr;
   (* Returns the Path and filename of a Configuration File(s) *)

function parfind(line : maxstr) : boolean;
   (* Returns true if it finds LINE in the parameters *)

function getparam(line : maxstr) : string;
   (* Returns the remaining portion of LINE in paramaters *)

function st_trail(s : maxstr) : maxstr;
   (* Strips Trailing Spaces *)

function addslash(line : maxstr) : maxstr;
   (* Adds a Slash if not there to LINE *)

function remslash(line : maxstr) : maxstr;
   (* Removes the Slash if there in LINE *)

function checkdate(yy,mm,dd : word) : boolean;
   (* Checks for a Valid Date *)

function wordtodate(temp : word;var yy,mm,dd : word) : boolean;
   (* Converts a Word to Date Format *)

function datetoword(yy,mm,dd : word) : word;
   (* Converts a Date to a Word Format *)

function st_lead(s : maxstr) : maxstr;
   (* Removes leading SPACES from a string *)

function retmessxxx(msgboard : word;t : byte) : maxstr;
   (* Returns the FULL path to a message area
      On entry if T = 1 then the Header Path is returned
               if T = 2 then the Text   Path is returned *)

function retfilexxx(filearea : word) : maxstr;
   (* Returns the FULL path to a file area *)

var
   systempath : maxstr;           { Path to System Files   }
   node       : byte;             { Node Number -N<1..250> }
   configrec  : configrecord;     { Configuration          }
   constant   : constantrecord;   { Constant               }

implementation


{$IFDEF Ver60} (* if turbo pascal V6.0 *)

function biton(position : byte;testword : word) : boolean; assembler;

asm
   mov ax, 1;
   mov cl, position;
   shl ax, cl;
   and ax, testword;
   jnz @notbiton
   mov ax, false;
   jmp @finish;
   @notbiton :
      mov ax, true;
   @finish :
end;

{$ELSE}

function biton(position : byte;testword : word) : boolean;

var
   bt : word;

begin
   bt := $01;
   bt := bt shl position;
   biton := (bt and testword) > 0;
end;

{$ENDIF}

procedure setbitword(position : byte;value : boolean;var changeword : word);
   (* Set a Bit at Position <0-15> to Value *)

var
   wd : word;

begin
   wd := $01;
   wd := wd shl position;
   if value then
      changeword := changeword or wd else
      begin
         wd := wd xor $ff;
         changeword := changeword and wd;
      end;
end;

procedure setbitbyte(position : byte;value : boolean;var changebyte : byte);
   (* Set a Bit at Position <0-7> to Value *)

var
   wd : byte;

begin
   wd := $01;
   wd := wd shl position;
   if value then
      changebyte := changebyte or wd else
      begin
         wd := wd xor $ff;
         changebyte := changebyte and wd;
      end;
end;


procedure setbit(position, value : byte; var changebyte : byte);

var
   bt : byte;

begin
   bt := $01;
   bt := bt shl position;
   if value = 1 then
      changebyte := changebyte or bt else
      begin
         bt := bt xor $ff;
         changebyte := changebyte and bt;
      end;
end;

function find(path : maxstr) : boolean;

var
   srec : searchrec;

begin
   findfirst(path,anyfile,srec);
   find := (doserror = 0);
end;

function itospad(x : longint;padout : byte) : str12;

var
   temp : str12;

begin
   str(x:padout,temp);
   for padout := 1 to length(temp) do
      if (temp[padout] = ' ') then
         temp[padout] := '0';
   itospad := temp;
end;

function dig2(s : word) : str2;

begin
   dig2 := itospad(s,2);
end;

function ItoS(x : longint) : str12;

var
   temp : string[12];

begin
   str(x,temp);
   itos := temp;
end;

function low2up(line : maxstr) : maxstr;

{var
   loop : integer;}

begin
{   for loop := 1 to length(line) do      ***** Pascal Equivalent *****
      line[loop] := upcase(line[loop]);
   low2up := line;}
INLINE(
  $1E/
  $C5/$76/$06/
  $C4/$7E/$0A/
  $FC/
  $AC/
  $AA/
  $30/$ED/
  $88/$C1/
  $E3/$0E/
  $AC/
  $3C/$61/
  $72/$06/
  $3C/$7A/
  $77/$02/
  $2C/$20/
  $AA/
  $E2/$F2/
  $1F);
end;

function findw(s : maxstr) : maxstr;

begin
   if find(systempath + s + '.' + itos(node)) then
      findw := systempath + s + '.' + itos(node) else
      if find(s + '.EZY') then
         findw := s + '.EZY' else
            findw := systempath + s + '.EZY';
end;

function getparam(line : maxstr) : string;

var
   loop     : integer;
   found    : boolean;
   posstart : byte;

begin
   loop := 1;
   found := false;
   while (loop <= paramcount) and (not found) do
      begin
         posstart := pos(line,low2up(paramstr(loop)));
         if (posstart = 1) then
            found := true else
            loop := loop + 1;
      end;
   if found then
      getparam := copy(paramstr(loop),posstart+length(line),255) else
      getparam := '';
end;

function st_trail(s : maxstr) : maxstr;

{var
   loop : integer;
   alpha : boolean;}

begin
{   alpha := false;
   for loop := length(s) downto 1 do           **** Pascal Equivalent ****
         if (s[loop] = ' ') and (not alpha) then
            s[0] := chr(ord(s[0]) -1) else
            alpha := true;
   st_trail := s;              }
INLINE(
  $1E/
  $C5/$76/$06/
  $FC/
  $AC/
  $3C/$00/
  $74/$21/
  $30/$ED/
  $88/$C1/
  $B0/$20/
  $C4/$7E/$06/
  $01/$CF/
  $FD/
  $F3/$AE/
  $74/$01/
  $41/
  $88/$C8/
  $C5/$76/$06/
  $46/
  $C4/$7E/$0A/
  $FC/
  $AA/
  $F2/$A4/
  $E9/$04/$00/
  $C4/$7E/$0A/
  $AA/
  $1F);
end;

function st_lead(s : maxstr) : maxstr;

var
   loop : word;
   slength : byte absolute s;

begin
   loop := 1;
   while (loop <= slength) and (s[loop] = ' ') do
      inc(loop);
   dec(loop);
   if (loop > 0) then
      delete(s, 1, loop);
   st_lead := s;
end;

function addslash(line : maxstr) : maxstr;

var
   llen : byte absolute line;

begin
   line := st_trail(line);
   if (llen > 0) and (line[llen] <> '\') then
      begin
         inc(llen);
         line[llen] := '\';
      end;
   addslash := line;
end;

function remslash(line : maxstr) : maxstr;

var
   llen : byte absolute line;

begin
   if (length(line) > 0) and (line[length(line)] = '\') then
      dec(llen);
   remslash := line;
end;

function parfind(line : maxstr) : boolean;

var
   loop : integer;
   found : boolean;

begin
   loop := 1;
   found := false;
   while (loop <= paramcount) and (not found) do
      if pos(line,low2up(paramstr(loop))) = 1 then
         found := true else
         loop := loop + 1;
   parfind := found;
end;

function checkdate(yy,mm,dd : word) : boolean;

const
   daysinmonth : array[1..12] of word =
      (31,29,31,30,31,30,31,31,30,31,30,31);

begin
   checkdate := false;
   if (mm < 1) or (mm > 12) then
      exit;
   if (dd < 1) or (dd > daysinmonth[mm]) then
      exit;
   if not ((yy mod 4 <> 0) and (dd = 29) and (mm=2)) then
      checkdate := true;
end;


function datetoword(yy,mm,dd : word) : word;

var
   tofield        : word;
   tempbyte       : byte;

begin
   datetoword := 65535;
   if not checkdate(yy,mm,dd) then
      exit;
   tofield := dd - 1;
   tofield := tofield + ((mm - 1) shl 5);
   if (yy < 1980) or (yy > (1980 + 127)) then
      exit;
   yy := yy - 1980;
   tofield := tofield + (yy shl 9);
   datetoword := tofield;
end;

function wordtodate(temp : word;var yy,mm,dd : word) : boolean;

begin
   if (temp = 65535) then
      begin
         wordtodate := false;
         exit;
      end else
         wordtodate := true;
   dd   := temp and 31 + 1;
   temp := temp shr 5;
   mm   := temp and 15 + 1;
   temp := temp shr 4;
   yy   := (temp and 127) + 1980;
end;

function retmessxxx(msgboard : word;t : byte) : maxstr;

var
   temp  : string[3];
   temp2 : string[3];

begin
   temp := itospad(msgboard,3);
   str(((msgboard-1) div 100) + 1,temp2);
   if t = 1 then
      retmessxxx := configrec.msgpath + 'AREA' + temp2 + '\MSGH' + temp + '.BBS' else
      retmessxxx := configrec.msgpath + 'AREA' + temp2 + '\MSGT' + temp + '.BBS';
end;

function retfilexxx(filearea : word) : maxstr;

var
   temp  : string[3];
   temp2 : string[3];

begin
   temp := itospad(filearea,3);
   str(((filearea-1) div 100) + 1,temp2);
   retfilexxx := configrec.filepath + 'AREA' + temp2 + '\FILE' + temp + '.BBS';
end;

procedure newsetup;

var
   tempfile   : file;
   tempstr    : maxstr;
   error      : integer;

begin
   systempath := getenv('EZY');
   if (length(systempath) = 0) then
      getdir(0,systempath);
   systempath := fexpand(addslash(low2up(systempath)));
   node := 1;
   tempstr := getenv('TASK');
   if (length(tempstr) > 0) then
      begin
         val(tempstr,node,error);
         if (error > 0) or (node = 0) then
            node := 1 else
         if (node > 250) then
            node := 250;
      end;
   tempstr := getparam('-N');
   if (length(tempstr) > 0) then
      begin
         val(tempstr,node,error);
         if (error > 0) or (node = 0) then
            node := 1 else
         if (node > 250) then
            node := 250;
      end;
   tempstr := findw('CONFIG');
   if not find(tempstr) then
      begin
         if (doserror = 3) then
            begin
               writeln(chr(254) + ' System Path Invalid.');
               writeln(chr(254) + ' Please Change EZY Environment Variable.');
               halt(1);
            end;
         writeln(chr(254) + ' CONFIG.EZY not found');
         writeln(chr(254) + ' Use CONFIG.EXE to Create it');
         halt(1);
      end;
   if not find(systempath + 'CONSTANT.EZY') then
      begin
         writeln(chr(254) + ' CONSTANT.EZY not found');
         writeln(chr(254) + ' Use CONFIG.EXE to Create it');
         halt(1);
      end;
   filemode := fdenynone + freadonly;
   assign(tempfile,systempath + 'CONSTANT.EZY');
   {$I-}
   repeat
      reset(tempfile,sizeof(constantrecord));
      error := ioresult;
      if (error = 5) then
         delay(500) else
      if (error <> 0) then
         runerror(error);
   until (error = 0);
   {$I+}
   blockread(tempfile,constant,1);
   close(tempfile);
   filemode := fdenynone + freadonly;
   assign(tempfile,tempstr);
   {$I-}
   repeat
      reset(tempfile,sizeof(configrec));
      error := ioresult;
      if (error = 5) then
         delay(500) else
      if (error <> 0) then
         runerror(error);
   until (error = 0);
   {$I+}
   blockread(tempfile,configrec,1);
   close(tempfile);
   checksnow   := configrec.snow_check;
end;


begin
   if (LastMode <> CO80) and (LastMode <> BW80) and
      (LastMode <> Mono) then
      TextMode(CO80);
   directvideo := false;
   textattr    := 7;
   newsetup;
end.